Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/ole/ole2bm/ole2bm.bas

BASIC Source File | 1994-09-22 | 14KB | 293 lines

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' OLE2BM.BAS ver. 1.3           VB 3.0 Pro Module                rev. 9/23/94
'____________________________________________________________________________
'
' The VB 3.0 Pro code in this module provides a way to transfer bitmap data
' back and forth between a bitmap object within an OLE 2.0 control (that's
' MSOLE2.VBX, not OLECLIENT.VBX!) and a picture box on a container form such
' that the user can edit the bitmap manually in PaintBrush along the way.
'
' This capability is useful when you wish to draw certain bitmap elements
' programmatically before or after hand editing.
'
' The considerable effort required in the support procedures below is quite
' typical of the wall one hits in attempting to gain programmatic control
' over data in embedded OLE 2.0 objects under VB.  Getting the data into the
' OLE2 control is relatively easy--getting it out is the hard part.
'
' If you know a simpler way to get the data out, or if you understand why some
' bitmap colors appear more muted in the OLE2 control's display than in the
' picture box, I'd love to hear from you!
'
' Version 1.3 is more robust than earlier releases because
'
'  1. The function OleFile2Picture() now buffers bitmap data read from disk in
'     a huge VB long integer array rather than a in VB string, thus lifting the
'     64K limit on the bitmaps it can extract from OLE2 files. Available memory
'     is now the only =realistic= limit; the absolute limit of 8 GB imposed by
'     the largest array index a long integer can specify shouldn't pose much of
'     a problem for the foreseeable future.  The array technique banks on the
'     fact that the image data in a Win 3.x DIB always starts on a dword boundary.
'  2. OleFile2Picture() makes =no= assumptions about class or object names in
'     the temporary OLE2 file header.  Apparently, such names may be absent.
'     Instead, OleFile2Picture() simply finds the first valid embedded bitmap
'     in the OLE2 file.
'  3. The tests for bitmap validity in OLEFile2Picture() have been tightened up
'     since version 1.2, but I'm sure they could be more rigorous.
'
'
'   Jeremy McCreary
'   Cliffshade Computing
'   CIS [72341,3716]
'____________________________________________________________________________

Option Explicit
DefInt A-Z

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Bitmap-related constants and data structures
'____________________________________________________________________________

Global Const OLE_CREATE_EMBED = 0   ' Ole control .Action settings
Global Const OLE_ACTIVATE = 7
Global Const OLE_SAVE_TO_FILE = 11

Global Const OLE_CHANGED = 0        ' Ole control .Updated event code

Global Const SRCCOPY = &HCC0020     ' BitBlt raster op: Overwrite destination

Global Const CBM_INIT = &H4&        ' Init created DIB with the data passed
Global Const DIB_RGB_COLORS = 0     ' DIB file color tables use RGB values

Type BitmapFileHeaderType ' File header common to =all= Win 3.x .BMP files
  bfType      As Integer  ' Always contains bitmap ID string "BM"
  bfSize      As Long     ' Bitmap file size in bytes, including this header
  bfReserved1 As Integer  ' Always null
  bfReserved2 As Integer  ' Always null
  bfOffBits   As Long     ' Offset from =start= of this header to start of data
End Type


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Data structures and variables for CVL().
'____________________________________________________________________________
Type LongType
    Numeric As Long
End Type

Type String4Type
    bytes As String * 4
End Type

Dim LongInt As LongType                ' Declare at module level for speed
Dim LongString As String4Type


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Required Windows 3.1 API declarations in type-safe form.
'____________________________________________________________________________

Declare Function BitBlt Lib "GDI" (ByVal DesthDC, ByVal DestX, ByVal DestY, ByVal DestWidth, ByVal DestHeight, ByVal SourcehDC, ByVal SourceX, ByVal SourceY, ByVal ROP As Long)
Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC)
Declare Function CreateDIBitmapPacked Lib "GDI" Alias "CreateDIBitmap" (ByVal hDC, lpPackedDIB As Long, ByVal InitFlag&, lpDataBits As Long, lpBitmapInfo As Long, ByVal ColorUse)
Declare Function DeleteDC Lib "GDI" (ByVal hDC)
Declare Function DeleteObject Lib "GDI" (ByVal hObj)
Declare Function GetTempFileName Lib "Kernel" (ByVal DriveLetterAscii, ByVal PrefixName$, ByVal Unique, ByVal NameBuffer$)
Declare Function SelectObject Lib "GDI" (ByVal hDC, ByVal hObject)

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Convert a 4-byte hexadecimal string to a long integer using type coercion.
'____________________________________________________________________________
Function CVL (bcd$) As Long

  LongString.bytes = bcd$
  LSet LongInt = LongString           ' Transfer 4 bytes between structures
  CVL = LongInt.Numeric               ' Data now in numeric format

End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Transfer an embedded bitmap object from an OLE 2.0 (MSOLE2.VBX) control to
' a VB picture box via the intermediaries of a temporary OLE file and a
' packed DIB memory structure.
'____________________________________________________________________________
Sub Ole2Pic (pic As PictureBox, ole As Control)
Dim f, h0, hbm, hmem, hpic, r
Dim file$

  file$ = TempFileName$("")       ' Open a temporary OLE file
  f = FreeFile
  Open file$ For Binary As f
  ole.FileNumber = f              ' Make its handle the save destination
  ole.Action = OLE_SAVE_TO_FILE   ' Save the embedded data as an OLE 2.0 file
  Close f

  hbm = OLEFile2Picture(pic, file$) ' Extract the bitmap from the OLE file
  If hbm Then                     ' Copy the extracted DDB into picture box
    hpic = pic.hDC
    hmem = CreateCompatibleDC(hpic)
    h0 = SelectObject(hmem, hbm)  ' Select the DDB into the memory DC
    r = BitBlt(hpic, 0, 0, CInt(pic.ScaleWidth), CInt(pic.ScaleHeight), hmem, 0, 0, SRCCOPY)
    r = SelectObject(hmem, h0)    ' Restore the object previously selected
    r = DeleteObject(hbm)         ' Recover system resources
    r = DeleteDC(hmem)
    pic.Refresh                   ' Update the screen now
  End If

  Kill file$                      ' Waste the temporary OLE file

End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Copy the 1st device-independent bitmap (DIB) found in a possibly compound
' OLE 2.0 file to a packed DIB memory image, create a device-dependent bitmap
' (DDB) from the packed DIB, and return the DDB handle for future reference
' if successful, 0 if not.
'
' NB: Once the DDB is created (i.e., once the packed DIB color table has been
' translated to the nearest available device-specific colors), subsequent
' display of the bitmap goes =much= faster than if displayed directly as a
' packed DIB, say with StretchDIBits().
'____________________________________________________________________________
Function OLEFile2Picture (pic As PictureBox, OLEfile$)
Dim hbm, hOLE, k, valid
Dim jj As Long, kk As Long
Dim bfhLen As Long, buffers As Long, bytes As Long, flength As Long
Dim ptr As Long, remainder As Long, start As Long
Dim BitmapOffset As Long
Dim buffer$
Dim bfh As BitmapFileHeaderType
Const BUFFER_SIZE = 2048& * 4&          ' File input buffer length must end on
Const STRING_LIMIT = 65500              '   dword boundary
Const MB = 16                           ' Stop style MsgBox
Const BitmapID$ = "BM"
Const MAX_BMINFO_SIZE = 40& + 256& * 4& ' BitmapInfo header for 256-color bitmap
Const MIN_BITMAP_SIZE = 14& + 40& + 16& * 4& + 2& ' Assume < 24-bit graphics

  bfhLen = Len(bfh)

  hOLE = FreeFile                       ' Open the source OLE file
  Open OLEfile$ For Binary As hOLE
  flength = LOF(hOLE)
  If flength <= MIN_BITMAP_SIZE Then    ' File too small to hold a bitmap
    MsgBox "Sorry, your OLE2 file is too small to contain a bitmap.", MB, "OLE2 File Error"
    GoTo OLEFile2PictureExit
  End If

  start = 1&                             ' Start at 1st byte of file
  bytes = flength

  Do                                     ' Search for 1st/next bitmap ID string
    buffers = bytes \ BUFFER_SIZE
    buffer$ = Space$(BUFFER_SIZE)
    Seek hOLE, start                     ' Set file pointer for reading start
    For k = 1 To buffers
      Get hOLE, , buffer$                ' Read a bufferfull of OLE file data
      ptr = InStr(buffer$, BitmapID$)    ' Look for a possible bitmap file header
      If ptr Then Exit For Else BitmapOffset = BitmapOffset + BUFFER_SIZE
    Next
    If ptr = 0 Then                      ' Check the tail
      remainder = bytes Mod BUFFER_SIZE
      buffer$ = Space$(remainder)        ' Now get what's left
      Get hOLE, , buffer$
      ptr = InStr(buffer$, BitmapID$)    ' Look one last time
    End If
    If ptr Then                          ' Check for a valid bitmap file header
      BitmapOffset = BitmapOffset + ptr
      Get hOLE, BitmapOffset, bfh        ' Read the bitmap file header
      bytes = bfh.bfSize - bfhLen        ' Calculate bitmap size
      valid = ((bytes > MAX_BMINFO_SIZE) And (BitmapOffset + bfhLen + bytes <= flength + 1&) And (bfh.bfOffBits <= bfhLen + MAX_BMINFO_SIZE) And (bfh.bfReserved1 * bfh.bfReserved2 = 0))
      If valid Then                      ' Header contents look reasonable for a bitmap
        ReDim PackedDIB(bytes / 4&) As Long ' Initialize dynamic array for packed DIB
        buffer$ = Space$(BUFFER_SIZE)
        buffers = bytes \ BUFFER_SIZE    ' Number of buffers needed to read bitmap
        remainder = bytes Mod BUFFER_SIZE
        ptr = 1&                         ' ptr -> 1st byte of bitmapinfo header
        jj = 0&                          ' jj -> next array element to fill
        Do Until ptr > bytes - remainder ' Build up a packed DIB memory image
          Get hOLE, , buffer$            '  a VB array, 1 bufferfull at a time
          For kk = 1& To BUFFER_SIZE - 3& Step 4&  ' Copy buffer to array
            PackedDIB(jj) = CVL(Mid$(buffer$, kk, 4))  ' kk -> dword to copy
            jj = jj + 1&
          Next
          ptr = ptr + BUFFER_SIZE        ' ptr -> next file byte to read
        Loop
        buffer$ = Space$(remainder)      ' Now get what's left
        Get hOLE, , buffer$
        kk = remainder Mod 4&            ' Pad buffer to dword boundary
        If kk Then buffer$ = buffer$ & String$(4& - kk, 0)
        For kk = 1& To remainder - 3& Step 4&  ' Copy buffer to array
          PackedDIB(jj) = CVL(Mid$(buffer$, kk, 4)) ' kk -> dword to copy
          jj = jj + 1&
        Next
        ptr = (bfh.bfOffBits - bfhLen) \ 4&  ' Array element starting DIB data bits
        ' Create a device-dependent bitmap (DDB) compatible with the target
        ' picture box device context.
        hbm = CreateDIBitmapPacked(pic.hDC, PackedDIB(0), CBM_INIT, PackedDIB(ptr), PackedDIB(0), DIB_RGB_COLORS)
        Exit Do                          ' Done--extracted first valid bitmap
      Else                               ' Try again--this is no embedded bitmap header!
        start = BitmapOffset + Len(BitmapID$) ' Skip over bogus bitmap ID string
        bytes = flength - start          ' Re-calculate remaining bytes
      End If
    Else                                 ' Done--no bitmap candidates found
      valid = False
      Exit Do
    End If
  Loop While bytes > MIN_BITMAP_SIZE

  If Not valid Then
      MsgBox "Sorry, couldn't find an embedded bitmap within your temporary OLE2 file.", MB, "OLE2 File Error"
  End If

OLEFile2PictureExit:
  Close hOLE                             ' Done with the OLE file
  OLEFile2Picture = hbm                  ' Pass back 0 if failed, DDB handle otherwise

End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Embed the bitmap contained within a VB picture box in an OLE 2.0 control
' (MSOLE2.VBX) via a temporary .BMP file.
'
' NB: The OLE control =requires= the .SourceDoc file to have the extension
' "BMP" in order to embed its data as a PaintBrush object.
'____________________________________________________________________________
Sub Pic2Ole (pic As PictureBox, ole As Control)
Dim r
Dim file$

  file$ = TempFileName$("BMP")   ' Get a temporary file name with .BMP ext.
  SavePicture pic.Image, file$   ' Save the picture box bitmap as a DIB file
  ole.Class = "PBrush"           ' Specify creation of Pbrush bitmap object
  ole.SourceDoc = file$          ' Make the temporary file the data source
  ole.Action = OLE_CREATE_EMBED  ' Embed the data as an OLE 2.0 object
  Kill file$                     ' Waste the temporary file

End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Create a temporary file, which will live briefly in the subdirectory
' specified by the user's TEMP environment variable--with luck perhaps
' on a ram drive for speed.
'____________________________________________________________________________
Function TempFileName$ (ext$)
Dim r
Dim file$
Const DOT = 46                            ' ANSI code for period

  file$ = Space$(255)                     ' Allow plenty of room for the name
  r = GetTempFileName(0, "", -1, file$)   ' Let Windows supply a name
  file$ = Trim(file$)                     ' Strip off any excess white space
  If Len(ext$) Then                       ' Replace the .TMP extension
    r = InStr(file$, ".TMP")              ' Find the .TMP extension
    If r Then                             ' Replace if present
      If Asc(ext$) <> DOT Then r = r + 1  ' Does ext. passed include period?
      Mid$(file$, r) = ext$               ' Replace .TMP with new extension
    End If
  End If

  TempFileName$ = file$                   ' Pass back the temporary file name

End Function